perm filename HOMF4.F4[XX,LCS]1 blob
sn#195563 filedate 1976-01-08 generic text, type T, neo UTF8
00200 SUBROUTINE HOMNEW
00400 REAL NWID
00600 INTEGER BSTF,BSTM
00800 COMMON /STF/RSTFAC(-3/4),RSTJ2
01000 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /POSI/STFF(-3/4),JJ2,POS
01200 COMMON /XRN/RN(4000) /PTR/KWDS(250),ITEM,L,IVVV,IX
01400 COMMON/ALF/I(72),HJG
01600 EQUIVALENCE (R3,RJQ(1)),(R6,RJQ(4)),(J11,JQ(9)),(RD,RN(4000))
01800 1,(R7,RJQ(5)),(R9,RJQ(7)),(R11,RJQ(9)),(R13,RJQ(11)),(J4,JQ(2))
02000 1,(J10,JQ(8)),(R8,RJQ(6)),(J7,JQ(5)),(STFDIR,I(2)),(J3,JQ(1))
02200 1,(BSTF,I(9)),(NSTF,I(6)),(NSTM,I(18)),(BSTM,I(22)),(NWID,I(15))
02400 1,(BWID,I(16))
02600
02800
03000 DIFF=ABS(STFF(BSTF)-STFF(NSTF))/(7.0*RSTFAC(BSTF))
03200 C ADD MINI FACTOR LATER
03400 CC STMRVS=13.71428571*RSTFAC(BSTF)*RSTJ2
03410 STMRVS=13.71428571*RSTJ2
03500 C RSTJ2=.6 FOR MINI-NOTES AND BEAMS
03600
03800 S1=BSTF
04000 S2=NSTF
04200 C FIND NOTES ON EITHER STAFF
04400
04600 JJ2=ITEM
04800 C IN CASE NOTHING IS DONE
05000 CC J=KWDS(J2)
05200 C ITEM # OF BEAM
05400 RNG1=RN(J2+3)-.1
05600 CC RNG2=RN(J+6)
05800 R=NWID
06000 IF(BSTM.EQ.NSTM)R=0
06200 10 IF(BSTM)R=-R
06400 C STEMS SAME=NO WIDTH TO BE ADDED
06600 RNG2=RN(I(1)+3)+R
06800 RN(J2+6)=RNG2
07000 C SETS LEFT SIDE OF BEAM
07200 C SETS RANGE
07400 CC DIS=RNG2-RNG1
07600 H1=AMOD(RN(J2+4),100.0)
07800 H2=RN(J2+5)
08000 CC HGT=H2-H1
08200 C BEAM VERT. SPREAD
08400 11 HFAC=(H2-H1)/(RNG2-RNG1)
08600 HQ=H1-RNG1*HFAC
08800 C STUFF TO DETERMINE HEIGHT AT NOTE'S POINT ALONG BEAM.
08900 RNG2=RNG2+NWID
08950 RDIF=DIFF
08975 IF(BSTM)RDIF=-RDIF
08981 IF(S2.LT.S1)RDIF=-RDIF
08987 C IF BEAM'S STEM IS UP USE NEG. DIFF.
09000 12 DO 100 K=1,ITEM
09200 L=KWDS(K)
09400 IF(RN(L+1).NE.1)GO TO 100
09600 C IS IT A NOTE?
09800 S=RN(L+2)
10000 IF(S.NE.S1.AND.S.NE.S2)GO TO 100
10200 C JUMP IF NOT ON EITHER STAFF
10400 RR=RN(L+3)
10600 IF(RR.LT.RNG1.OR.RR.GT.RNG2)GO TO 100
10800 C JUMP IF NOT IN RANGE OF BEAM
11000
11200 RWID=NWID
11400 SWID=BWID
11600 C THE NOTE WIDTH(HORIZ.) AND BEAM WIDTH(VERT.)
11800 B=AMOD(RN(L+4),100.0)
12000 C NOTE HEIGHT
12200 NN=0
12400 IF(RN(L+5).LT.20.)NN=-1
12600 13 IF(BSTM.NE.NN)GO TO 51
12800 RWID=0
13000 SWID=0
13200 C IGNORE WIDTHS IF BEAMS GO SAME DIR.
13400 CC A=H1+HGT*(RN(L+3)+RWID-RNG1)/DIS
13500 51 IF(BSTM)RWID=-RWID
13600 A=HQ+HFAC*(RN(L+3)+RWID)
13800 C HEIGHT OF BEAM AT NOTE POINT (WHEN STMS DIF DIR. +RWID IN ( )
14000 IF(BSTM.NE.NN)GO TO 1
14200 C JUMP IF STEMS GO DIFF. DIRECTIONS
14400 R=A-B
14600 C STEMS UP
14800 IF(BSTM.EQ.0)R=-R
15000 C STEMS DOWN
15200 IF(S.NE.S1)R=R+RDIF
15400 GO TO 50
15600
15800 1 R=B-A
16000 C DIFF STEM DIRS.
16200 IF(J3)GO TO 4
16400 C JUMP IF NOTE STAFF IS BELOW
16600 IF(J3.NE.0)GO TO 5
16800 IF(R.GE.0)GO TO 5
17000 4 R=-R
17200 5 R=DIFF-STMRVS+R+SWID
17400 50 RN(L+8)=R
17600 IF(JJ2.EQ.ITEM)JJ2=K
17700 NN=L+7
17750 IF(RN(NN).NE.0)RN(NN)=RN(NN)-AMOD(RN(NN),10.0)
17760 C TAKES OFF ANY TAILS
17800 100 CONTINUE
18000 END